COMMENT ⊗   VALID 00010 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	BEGIN "parser"    COMMENT: An interpreter for parse tables 
C00004 00003	! Description of the machine
C00006 00004	! How to match left_hand sides
C00008 00005	! Evaluating labels
C00009 00006	! Saving and restoring the parsing environment
C00011 00007	! The stack of procedures
C00012 00008	! Reading the source program
C00013 00009	! Initialization phase
C00014 00010	! Parsing
C00018 ENDMK
C⊗;
BEGIN "parser"    COMMENT: An interpreter for parse tables 
			   translated from PL by PTRANS;
require "INIT[CSP,SYS]" source_file;
define oct(zzz) = ⊂ "'"&cvos(zzz LAND '7777) ⊃;
define state = ⊂ oct(pc)&"["&cvs(bytpos)&"]" ⊃;

! The files below are the tables created by PTRANS.SAI for the use
of the parser;

require "LAB" source_file;
require "EXEC" source_file;
require "TABLE" source_file;


integer pc, bytpos;  ! The program counter;

integer dummy, i;

! The parsing stack;

define maxstack = ⊂ 50 ⊃;
ref(entri) array stack[1:maxstack]; integer stacktop;

! The stack for procedures;

define maxproc = ⊂ 30 ⊃;
integer array programstack[1:maxproc]; integer  programdepth;

ref(entri)
var0, var1, var2, var3, var4, var5, var6, var7, var8, var9, 
var10, var11, var12, var13, var14, var15, var16, var17, var18, var19;
! Description of the machine;

SIMPLE integer PROCEDURE getword;
	BEGIN
	integer result;
	parsedebug(crlf&tab&"PC: "&state);
	result ← case bytpos of
		(production[pc] lsh -24,
		(production[pc] lsh -12) land '7777,
		production[pc] land '7777);
	if result land '4000  then
		result ← result lor '777777770000;
	parsedebug(". Table element: "&oct(result)&"(i.e. "&cvs(result)&")");
	bytpos ← bytpos +1; if bytpos = 3 then
		BEGIN
		pc ← pc + 1; bytpos ← 0
		END;
	return(result)
	END;

SIMPLE procedure jump(VALUE integer elemnum);
	BEGIN
	pc ← (elemnum + 2) div 3 ;
	bytpos ← (elemnum + 2) mod 3;
	parsedebug(crlf&tab&"Jump to "&oct(pc)&"["&cvs(bytpos)&"]")
	END;

! How to match left_hand sides;

BOOLEAN PROCEDURE coincide (VALUE integer howmany);
	BEGIN
	RECURSIVE BOOLEAN procedure match(VALUE integer elmnt, matchtype);
		BEGIN
		boolean result;
		parsedebug(crlf&"Trying to match "&oct(elmnt)&" and "&oct(matchtype));
		result ← (matchtype= 0) ∨ (matchtype = elmnt);
		if result then 
			BEGIN parsedebug("  MATCH");
			return(TRUE)
			END
		else if matchtype ≤ lowerclass ∨ matchtype ≥ upperclass then
			BEGIN
			parsedebug("  DON'T MATCH");
			return(FALSE)
			END
		else
			BEGIN
			integer hashval;
			parsedebug(" Second is class. Enter recursion");
			hashval ← elmnt mod 10;
			do
				BEGIN
				parsedebug(crlf&"Triple "&oct(hashval));
				if (hashclass[hashval] lsh -24) = elmnt 
				∧ match((hashclass[hashval] land '77770000) lsh -12,matchtype)
				then
					BEGIN parsedebug("  MEMBER");
					return(TRUE)
					END
				else
					hashval ← hashclass[hashval] LAND '7777
				END
			until hashval = 0;
			parsedebug(" NO MATCH");
			return(FALSE)
			END
		END;
	for i ← (stacktop - howmany + 1) step 1 until stacktop do
		if ¬match(entri:rtype[stack[i]],getword) then
			return(FALSE);
	return(TRUE)
	END;
! Evaluating labels;

SIMPLE integer PROCEDURE getlab( VALUE integer nummlab);
	BEGIN
	integer result;
	integer wor, pos;
	wor ← (nummlab + 2)  div 3; pos ← (nummlab + 2) mod 3;

	result ← case pos of
		(labels[wor] lsh -24,
			(labels[wor] lsh -12) land '7777,
				labels[wor] land '7777);

	parsedebug(crlf&tab&"Label "&oct(nummlab)&" is production word "&oct(result));
	return(result)
	END;
! Saving and restoring the parsing environment;

SIMPLE PROCEDURE save(VALUE integer index);

if index > 0 then
	case stacktop - index of
		BEGIN
			var0  ← stack[stacktop];
			var1  ← stack[stacktop - 1 ];
			var2  ← stack[stacktop - 2 ];
			var3  ← stack[stacktop - 3 ];
			var4  ← stack[stacktop - 4 ];
			var5  ← stack[stacktop - 5 ];
			var6  ← stack[stacktop - 6 ];
			var7  ← stack[stacktop - 7 ];
			var8  ← stack[stacktop - 8 ];
			var9  ← stack[stacktop - 9 ];
			var10 ← stack[stacktop - 10];
			var11 ← stack[stacktop - 11];
			var12 ← stack[stacktop - 12];
			var13 ← stack[stacktop - 13];
			var14 ← stack[stacktop - 14];
			var15 ← stack[stacktop - 15];
			var16 ← stack[stacktop - 16];
			var17 ← stack[stacktop - 17];
			var18 ← stack[stacktop - 18];
			var19 ← stack[stacktop - 19]
		END;


SIMPLE ref(entri) PROCEDURE getback(VALUE integer index);

BEGIN
if index > 0 then
	return (case (stacktop - index) of
		(var0, var1, var2, var3,var4,var5,var6,var7,var8));
!	 ,var9,	var10,var11,var12,var13,var14,var15,var16,var17,var18,var19));
! LINE ABOVE CAUSES PROBLEMS FOR THE COMPILER;
error("restore called with a negative argument");
END;
! The stack of procedures;

SIMPLE integer PROCEDURE popretaddr;
	! Pop stack and get return address;
	if (programdepth ← programdepth - 1) < 0 then
		error("Procedure stack underflow")
	else
		return(programstack[programdepth]);


! Push new return address;

define pushretaddr(newaddr) =  ⊂
			if (programdepth ← programdepth + 1) > maxproc then
				error("Procedure stack overflow")
			else
				programstack[programdepth] ← newaddr ⊃;
! Reading the source program;

SIMPLE PROCEDURE sscan(VALUE integer how_many);
	for i ← 1 step 1 until how_many do
		BEGIN
		lexan;
		stacktop ← stacktop + 1;
		if stacktop > maxstack then
			error("Parse stack overflow");
		if token = tidentifier ∨ token = tdoubledelim then
			stack[stacktop] ← new_id
		else
			BEGIN
			entri:rtype[stack[stacktop]] ← token;
			DATUM(entri:name [stack[stacktop]]) ← symb
			END
		END;
! Initialization phase;
outstr("HAL file? "); 
initscan(instrl(crlf),17,FALSE);

debugparse ← please_answer("Debugging the parser?");
for i ← firstres step 1 until lastres do
	BEGIN
	dummy ← searchinsert(resword[i]);
	entri:rtype[new_id] ← i
	END;

if please_answer("Want to follow the scanning token after token?") then
	debugmode ← TRUE;
pc ← 1; bytpos ← 0;
! Parsing;
do
	BEGIN "interp"
	integer prodexecnum, numsucc, numfail, proccode;
	integer leftnum,  rightnum;
	boolean failed; 

	parsedebug(crlf&crlf&"Trying production "&state);
	numfail ← getword;
	parsedebug("  FAILURE LABEL");
	if numfail = 0 then
		DONE "interp";
	leftnum ← getword;parsedebug("  NO. OF LEFT ELEMENTS");
	failed ←  (stacktop < leftnum) ∨ ¬ coincide(leftnum);
	while failed do
		BEGIN "fail"
		parsedebug(crlf&tab&" Failed.");
		if numfail < 0 then
			jump(-numfail)
		else
			jump(getlab(numfail));
		parsedebug(crlf&"Trying production "&state);
		numfail ← getword;
		if numfail = 0 then
			DONE "interp";
		parsedebug("  FAILURE LABEL");
		leftnum ← getword;parsedebug("  NO. OF LAST ELEMENTS");
		failed ← (stacktop < leftnum) ∨ ¬ coincide(leftnum)
		END;
	for i ← 1 step 1 until leftnum do
		save(i);
	rightnum ← getword;PARSEDEBUG("  NO. OF RIGHT ELEMENTS");
	stacktop ← stacktop - leftnum + rightnum;
	for i ← 1 step 1 until rightnum  do
		BEGIN "replace"
		integer rightel;
		if (rightel ← getword) > 0 then
			entri:rtype[stack[stacktop - rightnum + i]] ← rightel
		else if rightel < 0 then
			stack[stacktop -rightnum + i] ← getback(-i);
		parsedebug("  RIGHT ELEMENT")
		END;
	prodexecnum ← getword;parsedebug("  NO. OF EXEC ROUTINES");
	for i ← 1 step 1 until prodexecnum do
		BEGIN
		integer ii; ii ← getword; parsedebug("  EXEC ROUTINE");
		exec(ii)
		END;
	i ← getword; parsedebug("  NUMBER OF SCANS"); sscan(i);
	numsucc ← getword;parsedebug("  SUCCESS LABEL");
	if numsucc = 0 then
		numsucc ← 3*(pc - 1) + bytpos + 2
	else
		numsucc ← getlab(numsucc);
	proccode ← getword; parsedebug("  PROCEDURE CODE");
	if proccode > 0 then
		BEGIN
		pushretaddr(numsucc); jump(getlab(proccode))
		END
	else if proccode < 0 then
		jump(popretaddr)
	else
		jump(numsucc)
	END
until false;
! The normal exit is by way of DONE above, otherwise looping goes on.;
END